home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / findfile / sendbug.frm < prev    next >
Text File  |  1999-08-28  |  9KB  |  330 lines
  1. VERSION 5.00
  2. Begin VB.Form Form7 
  3.    Appearance      =   0  '2D
  4.    BackColor       =   &H00808080&
  5.    BorderStyle     =   0  'Kein
  6.    Caption         =   "Send Bug Report"
  7.    ClientHeight    =   3192
  8.    ClientLeft      =   0
  9.    ClientTop       =   0
  10.    ClientWidth     =   4680
  11.    LinkTopic       =   "Form1"
  12.    MaxButton       =   0   'False
  13.    MinButton       =   0   'False
  14.    ScaleHeight     =   3192
  15.    ScaleWidth      =   4680
  16.    StartUpPosition =   2  'Bildschirmmitte
  17.    Begin VB.TextBox DataArrival 
  18.       Appearance      =   0  '2D
  19.       Height          =   288
  20.       Left            =   960
  21.       TabIndex        =   3
  22.       Text            =   "Text1"
  23.       Top             =   2760
  24.       Visible         =   0   'False
  25.       Width           =   1212
  26.    End
  27.    Begin VB.CommandButton Exit 
  28.       Appearance      =   0  '2D
  29.       Caption         =   "Exit"
  30.       Height          =   255
  31.       Left            =   2280
  32.       TabIndex        =   2
  33.       Top             =   2880
  34.       Width           =   2295
  35.    End
  36.    Begin VB.CommandButton SendBugConnect 
  37.       Appearance      =   0  '2D
  38.       Caption         =   "Send Feedback"
  39.       Height          =   255
  40.       Left            =   120
  41.       TabIndex        =   1
  42.       Top             =   2880
  43.       Width           =   2055
  44.    End
  45.    Begin VB.TextBox Bugreporttxt 
  46.       Appearance      =   0  '2D
  47.       Height          =   2655
  48.       Left            =   120
  49.       MultiLine       =   -1  'True
  50.       TabIndex        =   0
  51.       Top             =   120
  52.       Width           =   4455
  53.    End
  54. End
  55. Attribute VB_Name = "Form7"
  56. Attribute VB_GlobalNameSpace = False
  57. Attribute VB_Creatable = False
  58. Attribute VB_PredeclaredId = True
  59. Attribute VB_Exposed = False
  60. '*******************************************
  61. '*New Updates:
  62. '
  63. '-Api Declarations! (needs no Winsock.ocx)
  64. '
  65. '-Check if the Server respond with the right code
  66. '
  67. '-Perform a better error check
  68. '
  69. '-Use a better timeout routine to check if the Server
  70. 'times out
  71. '
  72. '
  73. '*******************************************
  74.  
  75. Option Explicit
  76. Private bTrans As Boolean
  77. Private m_iStage As Integer
  78. Private Sock As Integer
  79. Private RC As Integer
  80. Private Bytes As Integer
  81. Private ResponseCode As Integer
  82.  
  83. '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  84. 'CHANGE THIS SETTING LIKE YOU NEED IT
  85. '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  86. Private Const mailserver As String = "127.0.0.1"
  87. Private Const Tobox As String = "galgen@wtal.de"
  88. Private Const Frombox As String = "theuser@ofthisprogram.com"
  89. Private Const Subject As String = "User Feedback!"
  90.  
  91. 'This is for the WaitforResponse Routine
  92. Private Declare Function timeGetTime Lib "winmm.dll" () As Long
  93.  
  94.  
  95. '***************************************************************
  96. 'Routine for connecting to the server
  97. '***************************************************************
  98.  
  99. Sub SendBugConnect_Click()
  100. Dim StartupData As WSADataType
  101. Dim SocketBuffer As sockaddr
  102. Dim IpAddr As Long
  103.     
  104. 'Ini the Winsocket
  105. RC = WSAStartup(&H101, StartupData)
  106. RC = WSAStartup(&H101, StartupData)
  107.     
  108.  
  109.     
  110. 'Open a free Socket (with this source code you can also
  111. 'open several connections! Very useful for E-Mail Applications...)
  112. Sock = socket(AF_INET, SOCK_STREAM, 0)
  113. If Sock = SOCKET_ERROR Then
  114.     MsgBox "Cannot Create Socket."
  115.     Exit Sub
  116. End If
  117.  
  118. 'Checks if the Hostname exists
  119. If RC = SOCKET_ERROR Then Exit Sub
  120. IpAddr = GetHostByNameAlias(mailserver)
  121. If IpAddr = -1 Then
  122.     MsgBox "Unknown Host: " + mailserver
  123.     Exit Sub
  124. End If
  125.  
  126.  
  127. 'This part is responsible for the connection
  128. SocketBuffer.sin_family = AF_INET
  129. SocketBuffer.sin_port = htons(25)
  130. SocketBuffer.sin_addr = IpAddr
  131. SocketBuffer.sin_zero = String$(8, 0)
  132.     
  133. RC = connect(Sock, SocketBuffer, Len(SocketBuffer))
  134.  
  135. 'If an error occured close the connection and
  136. 'send an error message to the text window
  137. If RC = SOCKET_ERROR Then
  138.         MsgBox "Cannot Connect to " + mailserver + _
  139.                             Chr$(13) + Chr$(10) + _
  140.                             GetWSAErrorString(WSAGetLastError())
  141.         closesocket Sock
  142.         RC = WSACleanup()
  143.         Exit Sub
  144. End If
  145.  
  146. 'Select Receive Window
  147. RC = WSAAsyncSelect(Sock, DataArrival.hWnd, _
  148.                         ByVal &H202, ByVal FD_READ Or FD_CLOSE)
  149.     If RC = SOCKET_ERROR Then
  150.         MsgBox "Cannot Process Asynchronously."
  151.         closesocket Sock
  152.         RC = WSACleanup()
  153.         Exit Sub
  154.     End If
  155.  
  156. bTrans = True
  157. m_iStage = 0
  158. DataArrival = ""
  159.  
  160. ResponseCode = 220
  161. Call WaitForResponse
  162.  
  163. End Sub
  164.  
  165. '***************************************************************
  166. 'Transmit the E-Mail
  167. '***************************************************************
  168.  
  169. Private Sub Transmit(iStage As Integer)
  170. Dim Helo As String, temp As String
  171. Dim pos As Integer
  172.  
  173. Select Case m_iStage
  174.  
  175. Case 1:
  176.     Helo = Frombox
  177.     pos = Len(Helo) - InStr(Helo, "@")
  178.     Helo = Right$(Helo, pos)
  179.     
  180.     ResponseCode = 250
  181.     WinsockSendData ("HELO " & Helo & vbCrLf)
  182.     Call WaitForResponse
  183.  
  184. Case 2:
  185.     ResponseCode = 250
  186.     WinsockSendData ("MAIL FROM: <" & Trim(Frombox) & ">" & vbCrLf)
  187.     Call WaitForResponse
  188.  
  189. Case 3:
  190.     ResponseCode = 250
  191.     WinsockSendData ("RCPT TO: <" & Trim(Tobox) & ">" & vbCrLf)
  192.     Call WaitForResponse
  193.  
  194. Case 4:
  195.     ResponseCode = 354
  196.     WinsockSendData ("DATA" & vbCrLf)
  197.     Call WaitForResponse
  198.  
  199. Case 5:
  200.  
  201. '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  202. 'If you want additional Headers like Date,Message-Id,...etc. !
  203. 'simply add them below                                      !
  204. '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  205.     temp = temp & "From: " & Frombox & vbNewLine
  206.     temp = temp & "To: " & Tobox & vbNewLine
  207.     temp = temp & "Subject: " & Subject & vbNewLine
  208.  
  209.     'Header + Message
  210.     temp = temp & vbCrLf & Bugreporttxt.Text
  211.  
  212.     'Send the Message & close connection
  213.     WinsockSendData (temp)
  214.     WinsockSendData (vbCrLf & "." & vbCrLf)
  215.     ResponseCode = 250
  216.     Call WaitForResponse
  217.  
  218. Case 6:
  219.     MsgBox "E-Mail was successfuly sended!"
  220.     WinsockSendData ("QUIT" & vbCrLf)
  221.     ResponseCode = 221
  222.     Call WaitForResponse
  223.     m_iStage = 0
  224.     bTrans = False
  225. End Select
  226. End Sub
  227.  
  228.  
  229. '***************************************************************
  230. 'Routine for arraving Data
  231. '***************************************************************
  232.  
  233. Private Sub DataArrival_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
  234. Dim MsgBuffer As String * 2048
  235.  
  236.  
  237.     
  238. On Error Resume Next
  239.  
  240.  
  241.  
  242.     If Sock > 0 Then
  243.         'Receive up to 2048 chars
  244.         Bytes = recv(Sock, ByVal MsgBuffer, 2048, 0)
  245.         
  246.         If Bytes > 0 Then
  247.             
  248.                 
  249.         If bTrans Then
  250.             If ResponseCode = Left(MsgBuffer, 3) Then
  251.             MsgBuffer = vbNullString
  252.             m_iStage = m_iStage + 1
  253.             Transmit m_iStage
  254.             Else
  255.                 closesocket (Sock)
  256.                 RC = WSACleanup()
  257.                 Sock = 0
  258.                 MsgBox "The Server responds with an unexpected Response Code!", vbOKOnly, "Error!"
  259.                 Exit Sub
  260.             End If
  261.         End If
  262.  
  263.         ElseIf WSAGetLastError() <> WSAEWOULDBLOCK Then
  264.             closesocket (Sock)
  265.             RC = WSACleanup()
  266.             Sock = 0
  267.         End If
  268.     End If
  269.  
  270. Refresh
  271.  
  272.  
  273. End Sub
  274.  
  275. '**************************************************************
  276. ' Waits until time out, while waiting for response
  277. '**************************************************************
  278.  
  279. Private Sub WaitForResponse()
  280. Dim Start As Long
  281. Dim Tmr As Long
  282.  
  283. 'Works with an Api Declaration because it's more precious
  284.  
  285. Start = timeGetTime
  286. While Bytes > 0
  287.     Tmr = timeGetTime - Start
  288.     DoEvents ' Let System keep checking for incoming response
  289.         
  290.     'Wait 50 seconds for response
  291.     If Tmr > 50000 Then
  292.         MsgBox "SMTP service error, timed out while waiting for response", 64, "Error!"
  293.         End
  294.     End If
  295. Wend
  296. End Sub
  297.  
  298. Private Sub WinsockSendData(Da